home *** CD-ROM | disk | FTP | other *** search
/ NeXT Education Software Sampler 1992 Fall / NeXT Education Software Sampler 1992 Fall.iso / Programming / Source / winterp-1.13 / contrib / xmu / xmu-menu.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1991-10-06  |  6.1 KB  |  194 lines
  1. ; -*-Lisp-*-
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;
  4. ; File:         xmu-menu.lsp
  5. ; RCS:          $Header: $
  6. ; Description:  Xmu WINTERP-based menu server package
  7. ; Author:       Richard Hess, Consilium
  8. ; Created:      Sun Oct  6 00:06:05 1991
  9. ; Modified:     Sun Oct  6 00:07:07 1991 (Niels Mayer) mayer@hplnpm
  10. ; Language:     Lisp
  11. ; Package:      N/A
  12. ; Status:       X11r5 contrib tape release
  13. ;
  14. ; WINTERP Copyright 1989, 1990, 1991 Hewlett-Packard Company (by Niels Mayer).
  15. ; XLISP version 2.1, Copyright (c) 1989, by David Betz.
  16. ;
  17. ; Permission to use, copy, modify, distribute, and sell this software and its
  18. ; documentation for any purpose is hereby granted without fee, provided that
  19. ; the above copyright notice appear in all copies and that both that
  20. ; copyright notice and this permission notice appear in supporting
  21. ; documentation, and that the name of Hewlett-Packard and David Betz not be
  22. ; used in advertising or publicity pertaining to distribution of the software
  23. ; without specific, written prior permission.  Hewlett-Packard and David Betz
  24. ; make no representations about the suitability of this software for any
  25. ; purpose. It is provided "as is" without express or implied warranty.
  26. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  27.  
  28. ; +---------------------------------------------------------------------------
  29. ;  WHO:    Richard Hess                    CORP:   Consilium
  30. ;  TITLE:  Staff Engineer                  VOICE:  [415] 691-6342
  31. ;      [ X-SWAT Team:  Special Projects ]  USNAIL: 640 Clyde Court
  32. ;  UUCP:   ...!uunet!cimshop!rhess                 Mountain View, CA 94043
  33. ; +---------------------------------------------------------------------------
  34.  
  35. (defvar *xmu_timer*     nil )        ;; the active <timeout_obj>...
  36. (defvar *xmu_assoc*     nil )        ;; the menu-cache...
  37. (defvar *xmu_pick*      nil )        ;; the last menu pick... [ string ]
  38. (defvar *xmu_xtra*      32  )        ;; the max size of a menu... ****
  39. (defvar *xmu_lock*      nil )        ;; the menu server "LOCK"...
  40. (defvar *xmu_callback*  nil )        ;; the active menu callback...
  41. (defvar *xmu_color*    "red")        ;; the "null" menu background color...
  42.  
  43. (defun Xmu_Popup (key &optional xloc yloc cbk)
  44.   "[ Xmu ]:  popup a menu from the menu-cache..."
  45.   (setq *xmu_callback*  cbk)
  46.   (if *xmu_lock*
  47.       (progn (format T "ERROR:  menu server currently active...~%")
  48.          (Xmu_Error ":NoLock"))
  49.     (progn (setq *xmu_lock* t)
  50.        (let* ((lookup (assoc key *xmu_assoc*))
  51.           (menu (if lookup
  52.                 (cadr lookup)
  53.               nil))
  54.           )
  55.          (if menu
  56.          (progn (if (and xloc yloc)
  57.                 (send menu :SET_VALUES
  58.                   :XMN_X    xloc
  59.                   :XMN_Y    yloc)
  60.               (let ((xypos (get_mouse_location)))
  61.                 (send menu :SET_VALUES
  62.                   :XMN_X    (car xypos)
  63.                   :XMN_Y    (cdr xypos))))
  64.             (send menu :manage))
  65.            (progn (format T "ERROR:  invalid menu... [~S] ~%" key)
  66.               (Xmu_Error ":NoMenu")))
  67.          ))
  68.     ))
  69.  
  70. (defun Xmu_Menu (key heading entries &optional note)
  71.   "[ Xmu ]:  create a menu entry in the menu-cache..."
  72.   (let* ((xmu (send XM_ROW_COLUMN_WIDGET_CLASS :new :popup_menu
  73.             *TOPLEVEL_WIDGET*
  74.             ))
  75.      mlist
  76.      )
  77.     (send xmu
  78.       :add_callback :XMN_UNMAP_CALLBACK
  79.       '()
  80.       '((setq *xmu_timer*
  81.           (XT_ADD_TIMEOUT 200 '((Xmu_Error ":NoPick")))))
  82.       )
  83.     (if heading
  84.     (progn
  85.       (setq sbtn (send XM_LABEL_GADGET_CLASS :new :managed 
  86.                "menuLabel" xmu
  87.                :XMN_LABEL_STRING heading
  88.                ))
  89.       (send XM_SEPARATOR_GADGET_CLASS :new :managed "menuLine" xmu))
  90.       )
  91.     (Xmu_Menu_Items xmu entries)
  92.     (setq mlist (assoc key *xmu_assoc*))
  93.     (if mlist
  94.     (progn (format T "WARNING:  deleting existing menu... [~S] ~%" key)
  95.            (send (cadr mlist) :destroy)
  96.            (setq *xmu_assoc* (delete mlist *xmu_assoc*))
  97.            ))
  98.     (setq *xmu_assoc* (append (cons (cons key
  99.                      (cons xmu
  100.                            (cons note nil)))
  101.                     nil)
  102.                   *xmu_assoc*))
  103.     ))
  104.  
  105. (defun Xmu_Submenu (menu label entries)
  106.   "[ Xmu ]:  create a submenu entry for this menu..."
  107.   (let* ((xmu  (send XM_ROW_COLUMN_WIDGET_CLASS :new :pulldown_menu menu
  108.              ))
  109.      (xbtn (send XM_CASCADE_BUTTON_GADGET_CLASS :new :managed
  110.              "menuSub" menu
  111.              :XMN_LABEL_STRING label
  112.              :XMN_SUB_MENU_ID  xmu
  113.              ))
  114.      )
  115.     (Xmu_menu_items xmu entries)
  116.     ))
  117.  
  118. (defun Xmu_Menu_Items (menu entries)
  119.   "[ Xmu ]:  process the menu's entry list..."
  120.   (let ((nn 0)
  121.     (xmu menu)
  122.     xtra
  123.     xbtn
  124.     )
  125.     (dolist (elt entries)
  126.         (if (>= nn *xmu_xtra*)
  127.         (progn (setq xtra (send XM_ROW_COLUMN_WIDGET_CLASS :new 
  128.                     :pulldown_menu xmu
  129.                     ))
  130.                (setq xbtn (send XM_CASCADE_BUTTON_WIDGET_CLASS
  131.                     :new :managed "menuXtra" xmu
  132.                     :XMN_SUB_MENU_ID  xtra
  133.                     ))
  134.                (setq xmu xtra)
  135.                (setq nn 1)
  136.                )
  137.           (setq nn (+ nn 1))
  138.           )
  139.         (if (and elt
  140.              (listp elt))
  141.         (let ((label (car elt))
  142.               (tag   (cadr elt))
  143.               )
  144.           (if (and label
  145.                (listp tag))
  146.               (Xmu_Submenu xmu label tag)
  147.             (Xmu_String_Items xmu label tag)))
  148.           (Xmu_String_Items xmu elt nil)
  149.           ))
  150.     (if (and *xmu_color*
  151.          (eq nn 0))
  152.     (send xmu :SET_VALUES :XMN_BACKGROUND *xmu_color*))
  153.     ))
  154.  
  155. (defun Xmu_String_Items (menu label tag)
  156.   "[ Xmu ]:  create menu entries... [ button ][ seperator ]"
  157.   (if label
  158.       (let ((xbtn (send XM_PUSH_BUTTON_GADGET_CLASS :new :managed
  159.             "menuButton" menu
  160.             :XMN_LABEL_STRING label
  161.             ))
  162.         (xtag label)
  163.         )
  164.     (if tag (setq xtag tag))
  165.     (send xbtn
  166.           :add_callback :XMN_ACTIVATE_CALLBACK
  167.           '() '((Xmu_Pick xtag)))
  168.     )
  169.     (send XM_SEPARATOR_GADGET_CLASS :new :managed "menuLine" menu)
  170.     ))
  171.  
  172. (defun Xmu_Pick (tag)
  173.   "[ Xmu ]:  return the menu pick..."
  174.   (XT_REMOVE_TIMEOUT *xmu_timer*)
  175.   (if *xmu_callback*
  176.       (eval (list *xmu_callback* tag)))
  177.   (setq *xmu_timer*     nil)
  178.   (setq *xmu_pick*     (format nil "~A" tag))
  179.   (setq *xmu_callback*  nil)
  180.   (setq *xmu_lock*      nil)
  181.   )
  182.  
  183. (defun Xmu_Error (tag)
  184.   "[ Xmu ]:  return the menu error..."
  185.   (if *xmu_callback*
  186.       (eval (list *xmu_callback* tag)))
  187.   (setq *xmu_timer*     nil)
  188.   (setq *xmu_pick*      "")
  189.   (setq *xmu_callback*  nil)
  190.   (setq *xmu_lock*      nil)
  191.   )
  192.  
  193. ; -----------------------------------------------------------------------<eof>
  194.